home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / raise.test < prev    next >
Encoding:
Text File  |  1994-12-17  |  8.2 KB  |  302 lines
  1. # This file is a Tcl script to test out Tk's "raise" and
  2. # "lower" commands, plus associated code to manage window
  3. # stacking order.  It is organized in the standard fashion
  4. # for Tcl tests.
  5. #
  6. # Copyright (c) 1993-1994 The Regents of the University of California.
  7. # Copyright (c) 1994 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # @(#) raise.test 1.6 94/12/17 15:54:37
  13.  
  14. if {[info commands testmakeexist] == {}} {
  15.     puts "This application hasn't been compiled with the \"testmakeexist\""
  16.     puts "command, so I can't run this test.  Are you sure you're using"
  17.     puts "tktest instead of wish?"
  18.     return
  19. }
  20.  
  21. if {[string compare test [info procs test]] == 1} then \
  22.   {source defs}
  23.  
  24. # Procedure to create a bunch of overlapping windows, which should
  25. # make it easy to detect differences in order.
  26.  
  27. proc raise_setup {} {
  28.     foreach i [winfo child .raise] {
  29.     destroy $i
  30.     }
  31.     foreach i {a b c d e} {
  32.     label .raise.$i -text $i -relief raised -bd 2
  33.     }
  34.     place .raise.a -x 20 -y 60 -width 60 -height 80
  35.     place .raise.b -x 60 -y 60 -width 60 -height 80
  36.     place .raise.c -x 100 -y 60 -width 60 -height 80
  37.     place .raise.d -x 40 -y 20 -width 100 -height 60
  38.     place .raise.e -x 40 -y 120 -width 100 -height 60
  39. }
  40.  
  41. # Procedure to return information about which windows are on top
  42. # of which other windows.
  43.  
  44. proc raise_getOrder {} {
  45.     set x [winfo rootx .raise]
  46.     set y [winfo rooty .raise]
  47.     list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \
  48.         [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \
  49.         [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \
  50.         [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \
  51.         [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \
  52.         [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \
  53.         [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \
  54.         [winfo name [winfo containing [expr $x+130] [expr $y+130]]]
  55. }
  56.  
  57. # Procedure to set up a collection of top-level windows
  58.  
  59. proc raise_makeToplevels {} {
  60.     foreach i [winfo child .] {
  61.     destroy $i
  62.     }
  63.     foreach i {.raise1 .raise2 .raise3} {
  64.     toplevel $i
  65.     wm geom $i 150x100+0+0
  66.     update
  67.     }
  68. }
  69.  
  70. foreach i [winfo child .] {
  71.     destroy $i
  72. }
  73. toplevel .raise
  74. wm geom .raise 250x200+0+0
  75.  
  76. test raise-1.1 {preserve creation order} {
  77.     raise_setup
  78.     update
  79.     raise_getOrder
  80. } {d d d b c e e e}
  81. test raise-1.2 {preserve creation order} {
  82.     raise_setup
  83.     testmakeexist .raise.a
  84.     update
  85.     raise_getOrder
  86. } {d d d b c e e e}
  87. test raise-1.3 {preserve creation order} {
  88.     raise_setup
  89.     testmakeexist .raise.c
  90.     update
  91.     raise_getOrder
  92. } {d d d b c e e e}
  93. test raise-1.4 {preserve creation order} {
  94.     raise_setup
  95.     testmakeexist .raise.e
  96.     update
  97.     raise_getOrder
  98. } {d d d b c e e e}
  99. test raise-1.5 {preserve creation order} {
  100.     raise_setup
  101.     testmakeexist .raise.d .raise.c .raise.b
  102.     update
  103.     raise_getOrder
  104. } {d d d b c e e e}
  105.  
  106. test raise-2.1 {raise internal windows before creation} {
  107.     raise_setup
  108.     raise .raise.a
  109.     update
  110.     raise_getOrder
  111. } {a d d a c a e e}
  112. test raise-2.2 {raise internal windows before creation} {
  113.     raise_setup
  114.     raise .raise.c
  115.     update
  116.     raise_getOrder
  117. } {d d c b c e e c}
  118. test raise-2.3 {raise internal windows before creation} {
  119.     raise_setup
  120.     raise .raise.e
  121.     update
  122.     raise_getOrder
  123. } {d d d b c e e e}
  124. test raise-2.4 {raise internal windows before creation} {
  125.     raise_setup
  126.     raise .raise.e .raise.a
  127.     update
  128.     raise_getOrder
  129. } {d d d b c e b c}
  130. test raise-2.5 {raise internal windows before creation} {
  131.     raise_setup
  132.     raise .raise.a .raise.d
  133.     update
  134.     raise_getOrder
  135. } {a d d a c e e e}
  136.  
  137. test raise-3.1 {raise internal windows after creation} {
  138.     raise_setup
  139.     update
  140.     raise .raise.a .raise.d
  141.     raise_getOrder
  142. } {a d d a c e e e}
  143. test raise-3.2 {raise internal windows after creation} {
  144.     raise_setup
  145.     testmakeexist .raise.a .raise.b
  146.     raise .raise.a .raise.b
  147.     update
  148.     raise_getOrder
  149. } {d d d a c e e e}
  150. test raise-3.3 {raise internal windows after creation} {
  151.     raise_setup
  152.     testmakeexist .raise.a .raise.d
  153.     raise .raise.a .raise.b
  154.     update
  155.     raise_getOrder
  156. } {d d d a c e e e}
  157. test raise-3.4 {raise internal windows after creation} {
  158.     raise_setup
  159.     testmakeexist .raise.a .raise.c .raise.d
  160.     raise .raise.a .raise.b
  161.     update
  162.     raise_getOrder
  163. } {d d d a c e e e}
  164.  
  165. test raise-4.1 {raise relative to nephews} {
  166.     raise_setup
  167.     update
  168.     frame .raise.d.child
  169.     raise .raise.a .raise.d.child
  170.     raise_getOrder
  171. } {a d d a c e e e}
  172. test raise-4.2 {raise relative to nephews} {
  173.     raise_setup
  174.     update
  175.     frame .raise2
  176.     list [catch {raise .raise.a .raise2} msg] $msg
  177. } {1 {can't raise ".raise.a" above ".raise2"}}
  178. catch {destroy .raise2}
  179.  
  180. test raise-5.1 {lower internal windows} {
  181.     raise_setup
  182.     update
  183.     lower .raise.d
  184.     raise_getOrder
  185. } {a b c b c e e e}
  186. test raise-5.2 {lower internal windows} {
  187.     raise_setup
  188.     update
  189.     lower .raise.d .raise.b
  190.     raise_getOrder
  191. } {d b c b c e e e}
  192. test raise-5.3 {lower internal windows} {
  193.     raise_setup
  194.     update
  195.     lower .raise.a .raise.e
  196.     raise_getOrder
  197. } {a d d a c e e e}
  198. test raise-5.4 {lower internal windows} {
  199.     raise_setup
  200.     update
  201.     frame .raise2
  202.     list [catch {lower .raise.a .raise2} msg] $msg
  203. } {1 {can't lower ".raise.a" below ".raise2"}}
  204. catch {destroy .raise2}
  205.  
  206. if $doNonPortableTests {
  207.     test raise-6.1 {raise/lower toplevel windows} {
  208.     raise_makeToplevels
  209.     update
  210.     raise .raise1
  211.     winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
  212.     } .raise1
  213.     test raise-6.2 {raise/lower toplevel windows} {
  214.     raise_makeToplevels
  215.     update
  216.     raise .raise2
  217.     winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
  218.     } .raise2
  219.     test raise-6.3 {raise/lower toplevel windows} {
  220.     raise_makeToplevels
  221.     update
  222.     raise .raise3
  223.     raise .raise2
  224.     raise .raise1 .raise3
  225.     set result [winfo containing [winfo rootx .raise1] \
  226.         [winfo rooty .raise1]]
  227.     destroy .raise2
  228.     update
  229.     after 500
  230.     list $result [winfo containing [winfo rootx .raise1] \
  231.         [winfo rooty .raise1]]
  232.     } {.raise2 .raise1}
  233.     test raise-6.4 {raise/lower toplevel windows} {
  234.     raise_makeToplevels
  235.     update
  236.     raise .raise2
  237.     raise .raise1
  238.     lower .raise3 .raise1
  239.     set result [winfo containing [winfo rootx .raise1] \
  240.         [winfo rooty .raise1]]
  241.     wm geometry .raise2 +30+30
  242.     wm geometry .raise1 +60+60
  243.     destroy .raise1
  244.     update
  245.     after 500
  246.     list $result [winfo containing [winfo rootx .raise2] \
  247.         [winfo rooty .raise2]]
  248.     } {.raise1 .raise3}
  249.     test raise-6.5 {raise/lower toplevel windows} {
  250.     raise_makeToplevels
  251.     raise .raise1
  252.     set time [lindex [time {raise .raise1}] 0]
  253.     expr {$time < 2000000}
  254.     } 1
  255.     test raise-6.6 {raise/lower toplevel windows} {
  256.     raise_makeToplevels
  257.     update
  258.     raise .raise2
  259.     raise .raise1
  260.     raise .raise3
  261.     frame .raise1.f1
  262.     frame .raise1.f1.f2
  263.     lower .raise3 .raise1.f1.f2
  264.     set result [winfo containing [winfo rootx .raise1] \
  265.         [winfo rooty .raise1]]
  266.     destroy .raise1
  267.     update
  268.     after 500
  269.     list $result [winfo containing [winfo rootx .raise2] \
  270.         [winfo rooty .raise2]]
  271.     } {.raise1 .raise3}
  272. }
  273.  
  274. test raise-7.1 {errors in raise/lower commands} {
  275.     list [catch {raise} msg] $msg
  276. } {1 {wrong # args: should be "raise window ?aboveThis?"}}
  277. test raise-7.2 {errors in raise/lower commands} {
  278.     list [catch {raise a b c} msg] $msg
  279. } {1 {wrong # args: should be "raise window ?aboveThis?"}}
  280. test raise-7.3 {errors in raise/lower commands} {
  281.     list [catch {raise badName} msg] $msg
  282. } {1 {bad window path name "badName"}}
  283. test raise-7.4 {errors in raise/lower commands} {
  284.     list [catch {raise . badName2} msg] $msg
  285. } {1 {bad window path name "badName2"}}
  286. test raise-7.5 {errors in raise/lower commands} {
  287.     list [catch {lower} msg] $msg
  288. } {1 {wrong # args: should be "lower window ?belowThis?"}}
  289. test raise-7.6 {errors in raise/lower commands} {
  290.     list [catch {lower a b c} msg] $msg
  291. } {1 {wrong # args: should be "lower window ?belowThis?"}}
  292. test raise-7.7 {errors in raise/lower commands} {
  293.     list [catch {lower badName3} msg] $msg
  294. } {1 {bad window path name "badName3"}}
  295. test raise-7.8 {errors in raise/lower commands} {
  296.     list [catch {lower . badName4} msg] $msg
  297. } {1 {bad window path name "badName4"}}
  298.  
  299. foreach i [winfo child .] {
  300.     destroy $i
  301. }
  302.